home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue48 / System / Report.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1999-06-24  |  12.3 KB  |  404 lines
  1. unit Report;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.   StdCtrls, DCUDefs;
  8.  
  9. type
  10.   TReportForm = class(TForm)
  11.     OKButton: TButton;
  12.     Info: TMemo;
  13.     SaveDialog1: TSaveDialog;
  14.     Button1: TButton;
  15.     procedure FormShow(Sender: TObject);
  16.     procedure Button1Click(Sender: TObject);
  17.   private
  18.     { Private declarations }
  19.     p: PChar;
  20.     Buff: PChar;
  21.     Unknown: Boolean;
  22.     Version: TDCUVersion;
  23.     procedure PutStrUnderlined (const S: String);
  24.     procedure PutStr (const S: String);
  25.     procedure PutField (const Name, Val: String);
  26.     function  DCUReadString: String;
  27.     function  DCUDecodeNum: Integer;
  28.     procedure DCUUnknown (Tag, Offset: Integer);
  29.     procedure DCUDumpDFKRecord (const Typ: String);
  30.     procedure DCUTypeSymUse (const Typ: String);
  31.     procedure DCUDumpUsesRecord (const Typ: String);
  32.     procedure DCUProcDeclaration;
  33.     procedure DCUStdProcDeclaration;
  34.     function  DCUGetSymFlags (Flags: Integer): String;
  35.     procedure DCUParamDeclaration;
  36.     procedure DCUVariableDeclaration;
  37.     procedure DCUConstDeclaration;
  38.     procedure DCUTypeDeclaration;
  39.     procedure DCUVMTDeclaration;
  40.     procedure DCUTypedConstantDeclaration;
  41.     procedure DCUThreadVarDeclaration;
  42.     procedure DCUPutMagic (Flags: Integer);
  43.     procedure DCUIncrementLevel;
  44.     procedure DCUDecrementLevel;
  45.     procedure DCUUnitFlags;
  46.   public
  47.     { Public declarations }
  48.   end;
  49.  
  50. implementation
  51.  
  52. {$R *.DFM}
  53.  
  54. procedure TReportForm.PutStr (const S: String);
  55. begin
  56.     Info.Lines.Add (S);
  57. end;
  58.  
  59. procedure TReportForm.PutStrUnderlined (const S: String);
  60. var
  61.     Str: String;
  62. begin
  63.     PutStr (S);
  64.     Str := '';
  65.     while Length (Str) < Length (S) do Str := Str + '=';
  66.     PutStr (Str);
  67.     PutStr ('');
  68. end;
  69.  
  70. procedure TReportForm.PutField (const Name, Val: String);
  71. const
  72.     Offset = 20;
  73. var
  74.     S: String;
  75. begin
  76.     S := Name;
  77.     while Length (S) < Offset do S := S + ' ';
  78.     PutStr (S + Val);
  79. end;
  80.  
  81. procedure TReportForm.DCUUnknown (Tag, Offset: Integer);
  82. begin
  83.     Unknown := True;
  84.     PutField ('Unknown tag:', Format ('$%x at offset $%x', [Tag, Offset]));
  85. end;
  86.  
  87. function TReportForm.DCUReadString: String;
  88. var
  89.     Len: Byte;
  90. begin
  91.     Result := '';
  92.     Len := Ord (p^);  Inc (p);
  93.     while Len <> 0 do begin
  94.         Result := Result + p^;
  95.         Inc (p);  Dec (Len);
  96.     end;
  97. end;
  98.  
  99. function  TReportForm.DCUDecodeNum: Integer;
  100. const
  101.     SizeNum: array [0..15] of Byte = ( 1, 2, 1, 3, 1, 2, 1, 4, 1, 2, 1, 3, 1, 2, 1, 5 );
  102.     ShiftNum: array [0..15] of Byte = ( 25, 18, 25, 11, 25, 18, 25, 4, 25, 18, 25, 11, 25, 18, 25, 0 );
  103. var
  104.     Idx: Byte;
  105. begin
  106.     Idx := Ord (p^) and 15;
  107.     Inc (p, SizeNum [Idx]);
  108.     Result := PLongInt (p - 4)^ shr ShiftNum [Idx];
  109. end;
  110.  
  111. function TReportForm.DCUGetSymFlags (Flags: Integer): String;
  112. begin
  113.     Result := '[';
  114.     if (Flags and 1) <> 0 then Result := Result + 'value, ';
  115.     if (Flags and 2) <> 0 then Result := Result + 'assignable, ';
  116.     if (Flags and 4) <> 0 then Result := Result + 'constant, ';
  117.     if (Flags and 8) <> 0 then Result := Result + 'reg, ';
  118.     if (Flags and 16) <> 0 then Result := Result + 'mem, ';
  119.     if (Flags and 32) <> 0 then Result := Result + 'adr, ';
  120.     if (Flags and 64) <> 0 then Result := Result + 'exported, ';
  121.     if (Flags and 128) <> 0 then Result := Result + 'link or qual, ';
  122.     if Length (Result) > 1 then SetLength (Result, Length (Result) - 2);
  123.     Result := Result + ']';
  124. end;
  125.  
  126. procedure TReportForm.DCUParamDeclaration;
  127. var
  128.     Flags: Integer;
  129. begin
  130.     PutField ('Param:', DCUReadString);
  131.     Flags := DCUDecodeNum;
  132.     PutField ('ParamFlags:', '$' + IntToHex (Flags, 8) + DCUGetSymFlags (Flags));
  133.     PutField ('ParamType:', IntToStr (DCUDecodeNum));
  134.     PutField ('ParamLoc', IntToStr (DCUDecodeNum));
  135.     PutStr ('');
  136. end;
  137.  
  138. procedure TReportForm.DCUTypedConstantDeclaration;
  139. var
  140.     Flags: Integer;
  141. begin
  142.     PutField ('TypedConstant:', DCUReadString);
  143.     Flags := DCUDecodeNum;
  144.     PutField ('ParamFlags:', '$' + IntToHex (Flags, 8) + DCUGetSymFlags (Flags));
  145.     DCUPutMagic (Flags);
  146.     PutField ('typedconst1:', '$' + IntToHex (DCUDecodeNum, 8));
  147.     PutField ('typedconst2:', '$' + IntToHex (DCUDecodeNum, 8));
  148.     PutStr ('');
  149. end;
  150.  
  151. procedure TReportForm.DCUConstDeclaration;
  152. var
  153.     Flags: Integer;
  154. begin
  155.     PutField ('Constant:', DCUReadString);
  156.     Flags := DCUDecodeNum;
  157.     PutField ('ConstFlags:', '$' + IntToHex (Flags, 8) + DCUGetSymFlags (Flags));
  158.     PutField ('Const1:', '$' + IntToHex (PLongInt (p)^, 8));  Inc (p, 4);
  159.     PutField ('Const2:', '$' + IntToHex (DCUDecodeNum, 8));
  160.     PutField ('Const3:', '$' + IntToHex (DCUDecodeNum, 8));
  161.     PutField ('Value:', '$' + IntToHex (DCUDecodeNum, 8));
  162.     PutStr ('');
  163. end;
  164.  
  165. procedure TReportForm.DCUIncrementLevel;
  166. begin
  167.     PutStr ('Increment Level:');
  168.     PutStr ('');
  169. end;
  170.  
  171. procedure TReportForm.DCUDecrementLevel;
  172. begin
  173.     PutStr ('Decrement Level:');
  174.     PutStr ('');
  175. end;
  176.  
  177. procedure TReportForm.DCUUnitFlags;
  178. begin
  179.     PutField ('Unit Flags:', 'Flags = $' + IntToHex (DCUDecodeNum, 8));
  180.     if Version in [D4, D5, B3] then PutField ('Unit Flags:', 'Priority = $' + IntToHex (DCUDecodeNum, 8));
  181.     PutStr ('');
  182. end;
  183.  
  184. procedure TReportForm.DCUPutMagic (Flags: Integer);
  185. begin
  186.     // Magic is only present for exported symbols.
  187.     if (Flags and 64) <> 0 then begin
  188.         PutField ('Magic:', '$' + IntToHex (PLongInt (p)^, 8));
  189.         Inc (p, 4);
  190.     end;
  191. end;
  192.  
  193. procedure TReportForm.DCUThreadVarDeclaration;
  194. var
  195.     Flags: Integer;
  196. begin
  197.     PutField ('ThreadVar:', DCUReadString);
  198.     Flags := DCUDecodeNum;
  199.     PutField ('ThreadVarFlags:', '$' + IntToHex (Flags, 8) + DCUGetSymFlags (Flags));
  200.     DCUPutMagic (Flags);
  201.     PutField ('threadvar1:', '$' + IntToHex (DCUDecodeNum, 8));
  202.     PutField ('threadvar2:', '$' + IntToHex (DCUDecodeNum, 8));
  203.     PutStr ('');
  204. end;
  205.  
  206. procedure TReportForm.DCUVariableDeclaration;
  207. var
  208.     Flags: Integer;
  209. begin
  210.     PutField ('Variable:', DCUReadString);
  211.     Flags := DCUDecodeNum;
  212.     PutField ('VarFlags:', '$' + IntToHex (Flags, 8) + DCUGetSymFlags (Flags));
  213.     DCUPutMagic (Flags);
  214.     PutField ('VarType:', '$' + IntToHex (DCUDecodeNum, 8));
  215.     PutField ('VarLoc:', '$' + IntToHex (DCUDecodeNum, 8));
  216.     PutStr ('');
  217. end;
  218.  
  219. procedure TReportForm.DCUTypeDeclaration;
  220. var
  221.     Flags: Integer;
  222. begin
  223.     PutField ('Type:', DCUReadString);
  224.     Flags := DCUDecodeNum;
  225.     PutField ('TypeFlags:', '$' + IntToHex (Flags, 8) + DCUGetSymFlags (Flags));
  226.     DCUPutMagic (Flags);
  227.     PutField ('type1:', '$' + IntToHex (DCUDecodeNum, 8));
  228.     PutStr ('');
  229. end;
  230.  
  231. procedure TReportForm.DCUVMTDeclaration;
  232. var
  233.     Flags: Integer;
  234. begin
  235.     PutField ('VMT:', DCUReadString);
  236.     Flags := DCUDecodeNum;
  237.     PutField ('VMTFlags:', '$' + IntToHex (Flags, 8) + DCUGetSymFlags (Flags));
  238.     DCUPutMagic (Flags);
  239.     PutField ('vmt1:', '$' + IntToHex (DCUDecodeNum, 8));
  240.     PutField ('vmt2:', '$' + IntToHex (DCUDecodeNum, 8));
  241.     PutStr ('');
  242. end;
  243.  
  244. procedure TReportForm.DCUStdProcDeclaration;
  245. var
  246.     Flags: Integer;
  247. begin
  248.     PutField ('StdProc:', DCUReadString);
  249.     Flags := DCUDecodeNum;
  250.     PutField ('StdProcFlags:', '$' + IntToHex (Flags, 8) + DCUGetSymFlags (Flags));
  251.     PutField ('StdProcNum:', '$' + IntToHex (DCUDecodeNum, 8));
  252.     PutStr ('');
  253. end;
  254.  
  255. procedure TReportForm.DCUProcDeclaration;
  256. var
  257.     Flags: Integer;
  258. begin
  259.     PutField ('Procedure:', DCUReadString);
  260.     Flags := DCUDecodeNum;
  261.     PutField ('Proc Flags:', '$' + IntToHex (Flags, 8) + DCUGetSymFlags (Flags));
  262.     DCUPutMagic (Flags);
  263.     PutField ('proc1:', IntToStr (DCUDecodeNum));
  264.     PutField ('Code Size:', IntToStr (DCUDecodeNum) + ' bytes');
  265.     PutField ('ResultType:', IntToStr (DCUDecodeNum));
  266.     PutStr ('');
  267.  
  268.     while not Unknown do begin
  269.         Tag := Ord (p^);  Inc (p);
  270.         case Tag of
  271.             Tag_End_Record:    break;                       // All done!
  272.             Tag_Param:         DCUParamDeclaration;
  273.             Tag_Variable:      DCUVariableDeclaration;
  274.             else               DCUUnknown (Tag, p - Buff - 1);
  275.         end;
  276.     end;
  277. end;
  278.  
  279. procedure TReportForm.DCUDumpUsesRecord (const Typ: String);
  280. var
  281.     S, UnitName: String;
  282.     modTime: LongInt;
  283. begin
  284.     PutStrUnderlined (Format ('USES (%s)', [Typ]));
  285.     UnitName := DCUReadString;
  286.  
  287.     PutField ('UnitName:', UnitName);
  288.     modtime := PLongInt (p)^;  Inc (p, 4);
  289.     if modtime = 0 then S := '00000000' else try
  290.         S := FormatDateTime ('dddd, mmmm d, yyyy, hh:mm AM/PM', FileDateToDateTime (modtime));
  291.     except
  292.         { Eat exceptions if modtime is invalid } ;
  293.     end;
  294.  
  295.     PutField ('Modification Time:', S);
  296.  
  297.     while not Unknown do begin
  298.         Tag := Ord (p^);  Inc (p);
  299.         case Tag of
  300.             Tag_End_Record:    break;          // All done!
  301.             Tag_Type_Use:      DCUTypeSymUse ('Used Type:');
  302.             Tag_Sym_Use:       DCUTypeSymUse ('Used Symbol:');
  303.             else               DCUUnknown (Tag, p - Buff - 1);
  304.         end;
  305.     end;
  306.  
  307.     PutStr ('');
  308. end;
  309.  
  310. procedure TReportForm.DCUTypeSymUse (const Typ: String);
  311. var
  312.     TypName: String;
  313. begin
  314.     TypName := DCUReadString;
  315.     PutField (Typ, TypName + ' (Magic: $' + IntToHex (PLongInt (p)^, 8) + ')');
  316.     Inc (p, 4);
  317. end;
  318.  
  319. procedure TReportForm.DCUDumpDFKRecord (const Typ: String);
  320. var
  321.     modtime: LongInt;
  322. begin
  323.     PutField (Typ + ':', DCUReadString);
  324.  
  325.     try
  326.         modtime := PLongInt (p)^;  Inc (p, 4);
  327.         PutField ('Modification Time:', FormatDateTime ('dddd, mmmm d, yyyy, hh:mm AM/PM', FileDateToDateTime (modtime)));
  328.     except
  329.         { Eat exceptions if modtime is invalid } ;
  330.     end;
  331.  
  332.     PutField ('File Index:', IntToStr (DCUDecodeNum));
  333.     PutStr ('');
  334. end;
  335.  
  336. procedure TReportForm.FormShow(Sender: TObject);
  337. var
  338.     fs: TFileStream;
  339. begin
  340.     fs := TFileStream.Create (Caption, fmOpenRead);
  341.     try
  342.         PutStrUnderlined (Format ('Information on %s', [Caption]));
  343.         Caption := 'DCU Report information';
  344.         GetMem (Buff, fs.Size);
  345.         fs.Read (Buff^, fs.Size);
  346.     finally
  347.         fs.Free;
  348.     end;
  349.  
  350.     if Buff <> Nil then try
  351.         p := Buff;
  352.         // Get version number in an easily usable form
  353.         case PLongInt (p)^ of
  354.             D2Magic:  Version := D2;
  355.             D3Magic:  Version := D3;
  356.             D4Magic:  Version := D4;
  357.             D5Magic:  Version := D5;
  358.             B3Magic:  Version := B3;
  359.         end;
  360.  
  361.         // point at first byte of interest in DCU image
  362.         Inc (p, 12);
  363.         // If this isn't a Delphi 2 file, then there's an unknown 32-bit field to skip..
  364.         if Version <> D2 then Inc (p, 4);
  365.         // Now skip the ever-empty string field
  366.         DCUReadString;
  367.  
  368.         while not Unknown do begin
  369.             Tag := Ord (p^);  Inc (p);
  370.             case Tag of
  371.                 Tag_End:           break;     // All done!
  372.                 Tag_Int_Use:       DCUDumpUsesRecord ('Interface');
  373.                 Tag_Imp_Use:       DCUDumpUsesRecord ('Implementation');
  374.                 Tag_DLL_Import:    DCUDumpUsesRecord ('DLL Import');
  375.                 Tag_DFK_Source:    DCUDumpDFKRecord ('Source File');
  376.                 Tag_DFK_Object:    DCUDumpDFKRecord ('Object File');
  377.                 Tag_DFK_Resource:  DCUDumpDFKRecord ('Resource File');
  378.                 Tag_DFK_TheAdr:    DCUDumpDFKRecord ('Tag_DFK_TheAdr ????');
  379.                 Tag_Proc:          DCUProcDeclaration;
  380.                 Tag_StdProc:       DCUStdProcDeclaration;
  381.                 Tag_Const:         DCUConstDeclaration;
  382.                 Tag_VMT:           DCUVMTDeclaration;
  383.                 Tag_Type:          DCUTypeDeclaration;
  384.                 Tag_StructConst:   DCUTypedConstantDeclaration;
  385.                 Tag_Variable:      DCUVariableDeclaration;
  386.                 Tag_ThreadVar:     DCUThreadVarDeclaration;
  387.                 Tag_Unit_Flags:    DCUUnitFlags;
  388.                 Tag_Inc_Level:     DCUIncrementLevel;
  389.                 Tag_Dec_Level:     DCUDecrementLevel;
  390.                 else               DCUUnknown (Tag, p - Buff - 1);
  391.             end;
  392.         end;
  393.     finally
  394.         FreeMem (Buff);
  395.     end;
  396. end;
  397.  
  398. procedure TReportForm.Button1Click(Sender: TObject);
  399. begin
  400.     if SaveDialog1.Execute then Info.Lines.SaveToFile (SaveDialog1.FileName);
  401. end;
  402.  
  403. end.
  404.